home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / gnus / nnspool.el < prev    next >
Encoding:
Text File  |  1995-03-25  |  18.3 KB  |  548 lines
  1. ;;; nnspool.el --- spool access using NNTP for GNU Emacs
  2.  
  3. ;; Copyright (C) 1988, 1989, 1990, 1993 Free Software Foundation, Inc.
  4.  
  5. ;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
  6. ;; Keywords: news
  7.  
  8. ;; This file is part of XEmacs.
  9.  
  10. ;; XEmacs is free software; you can redistribute it and/or modify it
  11. ;; under the terms of the GNU General Public License as published by
  12. ;; the Free Software Foundation; either version 2, or (at your option)
  13. ;; any later version.
  14.  
  15. ;; XEmacs is distributed in the hope that it will be useful, but
  16. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  18. ;; General Public License for more details.
  19.  
  20. ;; You should have received a copy of the GNU General Public License
  21. ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  22. ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  23.  
  24. ;;; Code:
  25.  
  26. (require 'nntp)
  27.  
  28. (defvar nnspool-inews-program news-inews-program
  29.   "*Program to post news.")
  30.  
  31. (defvar nnspool-inews-switches '("-h")
  32.   "*Switches for nnspool-request-post to pass to `inews' for posting news.")
  33.  
  34. (defvar nnspool-spool-directory news-path
  35.   "*Local news spool directory.")
  36.  
  37. (defvar nnspool-active-file "/usr/lib/news/active"
  38.   "*Local news active file.")
  39.  
  40. (defvar nnspool-newsgroups-file "/usr/lib/news/newsgroups"
  41.   "*Local news newsgroups file.")
  42.  
  43. (defvar nnspool-distributions-file "/usr/lib/news/distributions"
  44.   "*Local news distributions file.")
  45.  
  46. (defvar nnspool-history-file "/usr/lib/news/history"
  47.   "*Local news history file.")
  48.  
  49. ;;; XEmacs addition: from Rick Sladkey <jrs@world.std.com>
  50. (defvar nnspool-retrieve-headers-method nil
  51.   "*Function to retrieve headers from articles in an nnspool directory.
  52. The function accepts a list of articles to retrieve the headers from where
  53. the articles are located in the directory nnspool-current-directory.  Three
  54. functions nnspool-retrieve-headers-from-overview-file, 
  55. nnspool-retrieve-headers-from-article-files and
  56. nnspool-retrieve-headers-using-gnushdrs are provided now.  For the
  57. latter nnspool-retrieve-headers-gnushdrs-program specifies the name
  58. of the program to execute (which see).  If the value is nil,
  59. automatically choose between the overview file and article files.")
  60.  
  61. (defvar nnspool-retrieve-headers-gnushdrs-program "gnushdrs"
  62.   "*The name of a program used to retrieve headers from articles
  63. when nnspool-retrieve-headers-method is set to 
  64. nnspool-retrieve-headers-using-gnushdrs.  The program takes a directory
  65. as it first argument and the files to retrieve articles from as the
  66. rest of its arguments.  It must produce on its standard output an
  67. emacs lisp expression in the same format as the value of
  68. nnspool-retrieve-headers (which see).")
  69.  
  70.  
  71.  
  72. (defconst nnspool-version "NNSPOOL 1.12"
  73.   "Version numbers of this version of NNSPOOL.")
  74.  
  75. (defvar nnspool-current-directory nil
  76.   "Current news group directory.")
  77.  
  78. ;;;
  79. ;;; Replacement of Extended Command for retrieving many headers.
  80. ;;;
  81.  
  82. ;; Suggested by scalzott@netcom6.netcom.com (Todd A. Scalzott)
  83. (defvar nnspool-article-header-read-size 1024
  84.   "Number of bytes to read when processing headers from NNSPOOL.")
  85.  
  86. ;;; XEmacs change: from Chris Davis <ckd@kei.com>
  87. ;;; UNIMPLEMENTED!  Probably can be implemented based on 
  88. ;;; nnspool-find-article-by-message-id.
  89. (defun nnspool-retrieve-headers-by-id (message-id)
  90.   "UNIMPLEMENTED.  Should return same things nnspool-retrieve-headers does."
  91.   (error "Unimplemented function, sorry."))
  92.  
  93. ;;; XEmacs change: from Rick Sladkey <jrs@world.std.com>
  94. (defun nnspool-retrieve-headers (sequence)
  95.   "Return list of article headers specified by SEQUENCE of article id.
  96. The format of list is
  97.  `([NUMBER SUBJECT FROM XREF LINES DATE MESSAGE-ID REFERENCES] ...)'.
  98. If there is no References: field, In-Reply-To: field is used instead.
  99. Reader macros for the vector are defined as `nntp-header-FIELD'.
  100. Writer macros for the vector are defined as `nntp-set-header-FIELD'.
  101. Newsgroup must be selected before calling this."
  102.   (if nnspool-retrieve-headers-method
  103.       (funcall nnspool-retrieve-headers-method sequence)
  104.     (if (file-exists-p (concat nnspool-current-directory ".overview"))
  105.     (nnspool-retrieve-headers-from-overview-file sequence)
  106.       (nnspool-retrieve-headers-from-article-files sequence))))
  107.  
  108. (defun nnspool-retrieve-headers-from-overview-file (sequence)
  109.   "A method for nnspool-retrieve-headers that uses .overview files."
  110.   (save-excursion
  111.     (set-buffer nntp-server-buffer)
  112.     (let ((next nil)
  113.       (article 0)
  114.       (subject nil)
  115.       (message-id nil)
  116.       (from nil)
  117.       (xref nil)
  118.       (lines nil)
  119.       (date nil)
  120.       (references nil)
  121.       (headers nil))
  122.       (erase-buffer)
  123.       (insert-file-contents (concat nnspool-current-directory ".overview"))
  124.       (goto-char (point-min))
  125.       (while sequence
  126.     (setq article (car sequence)
  127.           sequence (cdr sequence))
  128.     (if (and (re-search-forward (format "^%d\t" article) nil t)
  129.          (looking-at "\\([^\t\n]*\\)\t\\([^\t\n]*\\)\t\\([^\t\n]*\\)\t\\([^\t\n]*\\)\t\\([^\t\n]*\\)\t\\([^\t\n]*\\)\t\\([^\t\n]*\\)\t?\\([^\t\n]*\\)"))
  130.         (progn
  131.           (setq subject (buffer-substring (match-beginning 1)
  132.                           (match-end 1))
  133.             from (buffer-substring (match-beginning 2)
  134.                        (match-end 2))
  135.             date (buffer-substring (match-beginning 3)
  136.                        (match-end 3))
  137.             message-id (buffer-substring (match-beginning 4)
  138.                          (match-end 4))
  139.             references (buffer-substring (match-beginning 5)
  140.                          (match-end 5))
  141.             lines (string-to-int
  142.                (buffer-substring (match-beginning 7)
  143.                          (match-end 7)))
  144.             xref (and (/= (match-beginning 8) (match-end 8))
  145.                   (buffer-substring (+ (match-beginning 8) 6)
  146.                         (match-end 8)))
  147.             headers (progn
  148.                   (and (string= references "")
  149.                    (setq references nil))
  150.                   (cons (vector article subject from
  151.                         xref lines date
  152.                         message-id references) headers)))
  153.           (end-of-line)
  154.           (forward-char 1))
  155.       (and (looking-at "^\\([0-9]+\\)\t")
  156.            (setq next (string-to-int (buffer-substring (match-beginning 1)
  157.                                (match-end 1))))
  158.            (while (and sequence
  159.                (< (car sequence) next))
  160.          (setq sequence (cdr sequence))))))
  161.       (nreverse headers))))
  162.  
  163. (defun nnspool-retrieve-headers-using-gnushdrs (sequence)
  164.   "A method for nnspool-retrieve-headers that uses the program gnushdrs."
  165.   (save-excursion
  166.     (let ((msg (and (numberp nntp-large-newsgroup)
  167.             (> (length sequence) nntp-large-newsgroup))))
  168.       (set-buffer nntp-server-buffer)
  169.       (erase-buffer)
  170.       (let ((process-connection-type nil))
  171.     (apply 'call-process nnspool-retrieve-headers-gnushdrs-program
  172.            nil t nil nnspool-current-directory
  173.            (mapcar 'int-to-string sequence))
  174.     (and msg (message "NNSPOOL: parsing headers..."))
  175.     (goto-char (point-min))
  176.     (prog1
  177.         (read nntp-server-buffer)
  178.       (erase-buffer)
  179.       (and msg (message "NNSPOOL: parsing headers...done.")))))))
  180.  
  181. (defun nnspool-retrieve-headers-from-article-files (sequence)
  182.   "A method for nnspool-retrieve-headers that only uses Emacs Lisp."
  183.   (save-excursion
  184.     (set-buffer nntp-server-buffer)
  185.     ;;(erase-buffer)
  186.     (let ((file nil)
  187.       (number (length sequence))
  188.       (count 0)
  189.       (headers nil)            ;Result list.
  190.       (article 0)
  191.       (subject nil)
  192.       (message-id nil)
  193.       (from nil)
  194.       (xref nil)
  195.       (lines 0)
  196.       (date nil)
  197.       (references nil))
  198.       (while sequence
  199.     ;;(nntp-send-strings-to-server "HEAD" (car sequence))
  200.     (setq article (car sequence))
  201.     (setq file
  202.           (concat nnspool-current-directory (prin1-to-string article)))
  203.     (if (and (file-exists-p file)
  204.          (not (file-directory-p file)))
  205.         (progn
  206.           (erase-buffer)
  207.           (insert-file-contents file
  208.                     nil 0 nnspool-article-header-read-size)
  209.           ;; Make message body invisible.
  210.           (goto-char (point-min))
  211.           (search-forward "\n\n" nil 'move)
  212.           (narrow-to-region (point-min) (point))
  213.           ;; Fold continuation lines.
  214.           (goto-char (point-min))
  215.           (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t)
  216.         (replace-match " " t t))
  217.           ;; Make it possible to search for `\nFIELD'.
  218.           (goto-char (point-min))
  219.           (insert "\n")
  220.           ;; Extract From:
  221.           (goto-char (point-min))
  222.           (if (search-forward "\nFrom: " nil t)
  223.           (setq from (buffer-substring
  224.                   (point)
  225.                   (save-excursion (end-of-line) (point))))
  226.         (setq from "(Unknown User)"))
  227.           ;; Extract Subject:
  228.           (goto-char (point-min))
  229.           (if (search-forward "\nSubject: " nil t)
  230.           (setq subject (buffer-substring
  231.                  (point)
  232.                  (save-excursion (end-of-line) (point))))
  233.         (setq subject "(None)"))
  234.           ;; Extract Message-ID:
  235.           (goto-char (point-min))
  236.           (if (search-forward "\nMessage-ID: " nil t)
  237.           (setq message-id (buffer-substring
  238.                     (point)
  239.                     (save-excursion (end-of-line) (point))))
  240.         (setq message-id nil))
  241.           ;; Extract Date:
  242.           (goto-char (point-min))
  243.           (if (search-forward "\nDate: " nil t)
  244.           (setq date (buffer-substring
  245.                   (point)
  246.                   (save-excursion (end-of-line) (point))))
  247.         (setq date nil))
  248.           ;; Extract Lines:
  249.           (goto-char (point-min))
  250.           (if (search-forward "\nLines: " nil t)
  251.           (setq lines (string-to-int
  252.                    (buffer-substring
  253.                 (point)
  254.                 (save-excursion (end-of-line) (point)))))
  255.         (setq lines 0))
  256.           ;; Extract Xref:
  257.           (goto-char (point-min))
  258.           (if (search-forward "\nXref: " nil t)
  259.           (setq xref (buffer-substring
  260.                   (point)
  261.                   (save-excursion (end-of-line) (point))))
  262.         (setq xref nil))
  263.           ;; Extract References:
  264.           ;; If no References: field, use In-Reply-To: field instead.
  265.           (goto-char (point-min))
  266.           (if (or (search-forward "\nReferences: " nil t)
  267.               (search-forward "\nIn-Reply-To: " nil t))
  268.           (setq references (buffer-substring
  269.                     (point)
  270.                     (save-excursion (end-of-line) (point))))
  271.         (setq references nil))
  272.           ;; Collect valid article only.
  273.           (and article
  274.            message-id
  275.            (setq headers
  276.              (cons (vector article subject from
  277.                        xref lines date
  278.                        message-id references) headers)))
  279.           ))
  280.     (setq sequence (cdr sequence))
  281.     (setq count (1+ count))
  282.     (and (numberp nntp-large-newsgroup)
  283.          (> number nntp-large-newsgroup)
  284.          (zerop (% count 20))
  285.          (gnus-lazy-message "NNSPOOL: Receiving headers... %d%%"
  286.                 (/ (* count 100) number)))
  287.     )
  288.       (and (numberp nntp-large-newsgroup)
  289.        (> number nntp-large-newsgroup)
  290.        (message "NNSPOOL: Receiving headers... done"))
  291.       (nreverse headers)
  292.       )))
  293.  
  294.  
  295. ;;;
  296. ;;; Replacement of NNTP Raw Interface.
  297. ;;;
  298.  
  299. (defun nnspool-open-server (host &optional service)
  300.   "Open news server on HOST.
  301. If HOST is nil, use value of environment variable `NNTPSERVER'.
  302. If optional argument SERVICE is non-nil, open by the service name."
  303.   (let ((host (or host (getenv "NNTPSERVER")))
  304.     (status nil))
  305.     (setq nntp-status-string "")
  306.     (cond ((and (file-directory-p nnspool-spool-directory)
  307.         (file-exists-p nnspool-active-file)
  308.         (string-equal host (system-name)))
  309.        (setq status (nnspool-open-server-internal host service)))
  310.       ((string-equal host (system-name))
  311.        (setq nntp-status-string
  312.          (format "%s has no news spool.  Goodbye." host)))
  313.       ((null host)
  314.        (setq nntp-status-string "NNTP server is not specified."))
  315.       (t
  316.        (setq nntp-status-string
  317.          (format "NNSPOOL: cannot talk to %s." host)))
  318.       )
  319.     status
  320.     ))
  321.  
  322. (defun nnspool-close-server ()
  323.   "Close news server."
  324.   (nnspool-close-server-internal))
  325.  
  326. (fset 'nnspool-request-quit (symbol-function 'nnspool-close-server))
  327.  
  328. (defun nnspool-server-opened ()
  329.   "Return server process status, T or NIL.
  330. If the stream is opened, return T, otherwise return NIL."
  331.   (and nntp-server-buffer
  332.        (get-buffer nntp-server-buffer)))
  333.  
  334. (defun nnspool-status-message ()
  335.   "Return server status response as string."
  336.   nntp-status-string
  337.   )
  338.  
  339. (defun nnspool-request-article (id)
  340.   "Select article by message ID (or number)."
  341.   (let ((file (if (stringp id)
  342.           (nnspool-find-article-by-message-id id)
  343.         (concat nnspool-current-directory (prin1-to-string id)))))
  344.     (if (and (stringp file)
  345.          (file-exists-p file)
  346.          (not (file-directory-p file)))
  347.     (save-excursion
  348.       (nnspool-find-file file)))
  349.     ))
  350.  
  351. (defun nnspool-request-body (id)
  352.   "Select article body by message ID (or number)."
  353.   (if (nnspool-request-article id)
  354.       (save-excursion
  355.     (set-buffer nntp-server-buffer)
  356.     (goto-char (point-min))
  357.     (if (search-forward "\n\n" nil t)
  358.         (delete-region (point-min) (point)))
  359.     t
  360.     )
  361.     ))
  362.  
  363. (defun nnspool-request-head (id)
  364.   "Select article head by message ID (or number)."
  365.   (if (nnspool-request-article id)
  366.       (save-excursion
  367.     (set-buffer nntp-server-buffer)
  368.     (goto-char (point-min))
  369.     (if (search-forward "\n\n" nil t)
  370.         (delete-region (1- (point)) (point-max)))
  371.     t
  372.     )
  373.     ))
  374.  
  375. (defun nnspool-request-stat (id)
  376.   "Select article by message ID (or number)."
  377.   (setq nntp-status-string "NNSPOOL: STAT is not implemented.")
  378.   nil
  379.   )
  380.  
  381. (defun nnspool-request-group (group)
  382.   "Select news GROUP."
  383.   (let ((pathname (nnspool-article-pathname
  384.            (nnspool-replace-chars-in-string group ?. ?/))))
  385.     (if (file-directory-p pathname)
  386.     (setq nnspool-current-directory pathname))
  387.     ))
  388.  
  389. (defun nnspool-request-list ()
  390.   "List active newsgoups."
  391.   (save-excursion
  392.     (nnspool-find-file nnspool-active-file)))
  393.  
  394. (defun nnspool-request-list-newsgroups ()
  395.   "List newsgroups (defined in NNTP2)."
  396.   (save-excursion
  397.     (nnspool-find-file nnspool-newsgroups-file)))
  398.  
  399. (defun nnspool-request-list-distributions ()
  400.   "List distributions (defined in NNTP2)."
  401.   (save-excursion
  402.     (nnspool-find-file nnspool-distributions-file)))
  403.  
  404. (defun nnspool-request-last ()
  405.   "Set current article pointer to the previous article
  406. in the current news group."
  407.   (setq nntp-status-string "NNSPOOL: LAST is not implemented.")
  408.   nil
  409.   )
  410.  
  411. (defun nnspool-request-next ()
  412.   "Advance current article pointer."
  413.   (setq nntp-status-string "NNSPOOL: NEXT is not implemented.")
  414.   nil
  415.   )
  416.  
  417. (defun nnspool-request-post ()
  418.   "Post a new news in current buffer."
  419.   (save-excursion
  420.     ;; We have to work in the server buffer because of NEmacs hack.
  421.     (copy-to-buffer nntp-server-buffer (point-min) (point-max))
  422.     (set-buffer nntp-server-buffer)
  423.     (apply (function call-process-region)
  424.        (point-min) (point-max)
  425.        nnspool-inews-program 'delete t nil nnspool-inews-switches)
  426.     (prog1
  427.     (or (zerop (buffer-size))
  428.         ;; If inews returns strings, it must be error message 
  429.         ;;  unless SPOOLNEWS is defined.  
  430.         ;; This condition is very weak, but there is no good rule 
  431.         ;;  identifying errors when SPOOLNEWS is defined.  
  432.         ;; Suggested by ohm@kaba.junet.
  433.         (string-match "spooled" (buffer-string)))
  434.       ;; Make status message by unfolding lines.
  435.       (subst-char-in-region (point-min) (point-max) ?\n ?\\ 'noundo)
  436.       (setq nntp-status-string (buffer-string))
  437.       (erase-buffer))
  438.     ))
  439.  
  440.  
  441. ;;;
  442. ;;; Replacement of Low-Level Interface to NNTP Server.
  443. ;;; 
  444.  
  445. (defun nnspool-open-server-internal (host &optional service)
  446.   "Open connection to news server on HOST by SERVICE (default is nntp)."
  447.   (save-excursion
  448.     (if (not (string-equal host (system-name)))
  449.     (error "NNSPOOL: cannot talk to %s." host))
  450.     ;; Initialize communication buffer.
  451.     (setq nntp-server-buffer (get-buffer-create " *nntpd*"))
  452.     (set-buffer nntp-server-buffer)
  453.     (buffer-disable-undo (current-buffer))
  454.     (erase-buffer)
  455.     (kill-all-local-variables)
  456.     (setq case-fold-search t)        ;Should ignore case.
  457.     (if  (boundp 'nntp-server-process)
  458.     (setq nntp-server-process nil))
  459.     (setq nntp-server-name host)
  460.     ;; It is possible to change kanji-fileio-code in this hook.
  461.     (run-hooks 'nntp-server-hook)
  462.     t
  463.     ))
  464.  
  465. (defun nnspool-close-server-internal ()
  466.   "Close connection to news server."
  467.   (if (get-file-buffer nnspool-history-file)
  468.       (kill-buffer (get-file-buffer nnspool-history-file)))
  469.   (if nntp-server-buffer
  470.       (kill-buffer nntp-server-buffer))
  471.   (setq nntp-server-buffer nil)
  472.   (if (boundp 'nntp-server-process)
  473.       (setq nntp-server-process nil)))
  474.  
  475. (defun nnspool-find-article-by-message-id (id)
  476.   "Return full pathname of an article identified by message-ID."
  477.   (if (file-exists-p (concat nnspool-current-directory ".overview"))
  478.       (nnspool-find-article-by-message-id-from-overview-file id)
  479.     (nnspool-find-article-by-message-id-from-history-file id)))
  480.  
  481. (defun nnspool-find-article-by-message-id-from-overview-file (id)
  482.   ;; Look up article by message-id in the overview file.
  483.   (save-excursion
  484.     (set-buffer nntp-server-buffer)
  485.     (erase-buffer)
  486.     (insert-file-contents (concat nnspool-current-directory ".overview"))
  487.     (goto-char (point-min))
  488.     (if (re-search-forward (concat "^\\([^\t\n]*\\)\t[^\t\n]*\t[^\t\n]*\t[^\t\n]*\t"
  489.                    (regexp-quote id)
  490.                    "\t") nil t)
  491.     (concat nnspool-current-directory (buffer-substring (match-beginning 1)
  492.                                 (match-end 1)))
  493.       ;; The parent might be in a different newsgroup.
  494.       (nnspool-find-article-by-message-id-from-history-file id))))
  495.     
  496. (defun nnspool-find-article-by-message-id-from-history-file (id)
  497.   ;; Look up article by message-id in the history file.
  498.   (save-excursion
  499.     (let ((buffer (get-file-buffer nnspool-history-file)))
  500.       (if buffer
  501.       (set-buffer buffer)
  502.     ;; Finding history file may take lots of time.
  503.     (message "Reading history file...")
  504.     (set-buffer (find-file-noselect nnspool-history-file))
  505.     (message "Reading history file... done")))
  506.     ;; Search from end of the file. I think this is much faster than
  507.     ;; do from the beginning of the file.
  508.     (goto-char (point-max))
  509.     (if (re-search-backward
  510.      (concat "^" (regexp-quote id)
  511.          "[ \t].*[ \t]\\([^ \t/]+\\)/\\([0-9]+\\)[ \t]*$") nil t)
  512.     (let ((group (buffer-substring (match-beginning 1) (match-end 1)))
  513.           (number (buffer-substring (match-beginning 2) (match-end 2))))
  514.       (concat (nnspool-article-pathname
  515.            (nnspool-replace-chars-in-string group ?. ?/))
  516.           number))
  517.       )))
  518.  
  519. (defun nnspool-find-file (file)
  520.   "Insert FILE in server buffer safely."
  521.   (set-buffer nntp-server-buffer)
  522.   (erase-buffer)
  523.   (condition-case ()
  524.       (progn (insert-file-contents file) t)
  525.     (file-error nil)
  526.     ))
  527.  
  528. (defun nnspool-article-pathname (group)
  529.   "Make pathname for GROUP."
  530.   (concat (file-name-as-directory nnspool-spool-directory) group "/"))
  531.  
  532. (defun nnspool-replace-chars-in-string (string from to)
  533.   "Replace characters in STRING from FROM to TO."
  534.   (let ((string (substring string 0))    ;Copy string.
  535.     (len (length string))
  536.     (idx 0))
  537.     ;; Replace all occurrences of FROM with TO.
  538.     (while (< idx len)
  539.       (if (= (aref string idx) from)
  540.       (aset string idx to))
  541.       (setq idx (1+ idx)))
  542.     string
  543.     ))
  544.  
  545. (provide 'nnspool)
  546.  
  547. ;;; nnspool.el ends here
  548.